home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / HEAPSPY.ZIP / HWGLOBAL.PAS < prev    next >
Pascal/Delphi Source File  |  1992-10-27  |  23KB  |  866 lines
  1. {$A-,B-,E-,F-,G+,I-,K-,N-,O-,P-,Q-,R-,S-,T+,V-,W-,X+}
  2.  
  3. {**********************************************}
  4. {                                              }
  5. {   HeapSpy - HWGlobal Module                  }
  6. {   Copyright (c) 1992  Borland International  }
  7. {                                              }
  8. {**********************************************}
  9.  
  10. unit HWGlobal;
  11.  
  12. {$C MOVEABLE PRELOAD PERMANENT}
  13.  
  14. interface
  15.  
  16. uses WinTypes, WinProcs, Strings, WinDOS, Objects, ODialogs, OWindows,
  17.   BWCC, CommDlg, ToolHelp, WIN31;
  18.  
  19. {$I HEAPSPY.INC}
  20. {$I HELPIDS.INC}
  21.  
  22. const
  23.  
  24.   { Revision control information }
  25.   AppName: PChar = 'HEAPSPY';
  26.   MajorVersion  = 1;
  27.   MinorVersion  = 0;
  28.   RevisionChar  = ' ';
  29.  
  30.   { INI Control Info }
  31.   OptionsKey: PChar = 'Options';
  32.   RebuildKey: PChar = 'RebuildOnActivate';
  33.   SortOptKey: PChar = 'DefaultSortOpt';
  34.   WinTileKey: PChar = 'WindowTile';
  35.   SpeedBarKey: PChar = 'UseSpeedbar';
  36.   INIFile: PChar = 'HEAPSPY.INI';
  37.  
  38.   { Global Options settings }
  39. var
  40.   Glbl: record
  41.     RebuildOnActivate: WordBool;
  42.     UseSpeedBar: WordBool;
  43.     WinTile: array[op_Vertical..op_Horizontal] of WordBool;
  44.     SortOpt: array[cm_sbAddress..cm_sbModule] of WordBool;
  45.   end;
  46.  
  47. const
  48.   lbn_RDBLCLK = 6;
  49.   lbn_RDBLCLKMask = $00060000;
  50.   user_UpdateSpeed = wm_user + 1001;
  51.  
  52.   { New Global heap types (internally manufactured) }
  53.   gt_TPWheap = 11;
  54.  
  55.   LocalUserLit: array[1..32] of PChar = (
  56.     'Class', 'Wnd', 'String', 'Menu', 'Clip', 'CBox', 'Palette', 'ED',
  57.     'BWL', 'OwnerDraw', 'SPB', 'Checkpoint', 'DCE', 'MWP', 'Prop', 'LBIV',
  58.     'Misc', 'Atoms', 'LockInputState', 'HookList', 'UserSeeUserDoAlloc',
  59.     'HotkeyList', 'PopupMenu', '24', '25', '26', '27', '28', '29', '30',
  60.     '31', 'HandleTable');
  61.  
  62.   LocalGDILit: array[1..10] of PChar = (
  63.     'Pen', 'Brush', 'Font', 'Palette', 'Bitmap', 'RGN', 'DC', 'Disabled_DC',
  64.     'MetaDC', 'Metafile');
  65.  
  66.   GlobalResLit: array[0..15] of PChar = (
  67.     'UserDefined', 'CursorComponent', 'Bitmap', 'IconComponent', 'Menu',
  68.     'Dialog', 'String', 'FontDir', 'Font', 'Accelerators', 'RCData',
  69.     'ErrTable', 'Cursor', '13', 'Icon', 'NameTable');
  70.  
  71.   GlobalTypeLit: array[0..11] of PChar = (
  72.     'Private', 'DGroup', 'Data', 'Code', 'Task', 'Resource', 'Module',
  73.     'Free', 'Internal', 'Sentinel', 'BurgerMaster', 'TPW Heap');
  74.  
  75. var
  76.   WaitCursor: Word;
  77.   ArrowCursor: Word;
  78.   HeapFontLF : TLogFont;
  79.   ListboxFont: HFont;
  80.   HexDumpLF  : TLogFont;
  81.   HexDumpFont: HFont;
  82.  
  83. { TPW Heap sub-allocator structures }
  84. type
  85.   PTPWSubBlock = ^TTPWSubBlock;
  86.   TTPWSubBlock = record
  87.     Signature: Word; { $5054 }
  88.     Reserved1: Word;
  89.     FreeList : Word;
  90.     Reserved2: Word;
  91.     MemFree  : Word;
  92.     NextHeap : Word;
  93.   end;
  94.  
  95.   PTPWFreeEntry = ^TTPWFreeEntry;
  96.   TTPWFreeEntry = record
  97.     Next: Word;
  98.     Size: Word;
  99.   end;
  100.  
  101.   PMyListBox = ^TMyListBox;
  102.   TMyListBox = object(TListBox)
  103.     procedure WMRButtonDown(var Msg: TMessage);
  104.       virtual wm_First + wm_RButtonDown;
  105.     procedure WMRButtonUp(var Msg: TMessage);
  106.       virtual wm_First + wm_RButtonUp;
  107.     procedure WMRButtonDblClk(var Msg: TMessage);
  108.        virtual wm_First + wm_RButtonDblClk;
  109.     procedure WMKeyDown(var Msg: TMessage);
  110.        virtual wm_First + wm_KeyDown;
  111.   end;
  112.  
  113.   PBWCCDlg = ^TBWCCDlg;
  114.   TBWCCDlg = object(TDialog)
  115.     HelpCtx: LongInt;
  116.     constructor Init(AParent: PWindowsObject; AName: PChar;
  117.       AHelpCtx: LongInt);
  118.     function GetClassName: PChar; virtual;
  119.     procedure WMDestroy(var Msg: TMessage);
  120.       virtual wm_First + wm_Destroy;
  121.     procedure HelpReq(var Msg: TMessage);
  122.       virtual id_First + idHelp;
  123.   end;
  124.  
  125.   PBasicHexWin = ^TBasicHexWin;
  126.   TBasicHexWin = object(TWindow)
  127.   end;
  128.  
  129.   PListWin = ^TListWin;
  130.   TListWin = object(TWindow)
  131.     List: PMyListBox;
  132.     PrevChildWnd: hWnd;
  133.     constructor Init(AParent: PWindowsObject; ATitle: PChar;
  134.       AOwnerDraw: Boolean);
  135.     function GetClassName: PChar; virtual;
  136.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  137.     procedure SetupWindow; virtual;
  138.     function HandleSelect(LeftClick: Boolean): Boolean; virtual;
  139.     function GetItemString(p: pointer): PChar; virtual;
  140.     procedure DeleteItem(p: pointer); virtual;
  141.     procedure BuildList; virtual;
  142.     function Less(p1,p2: pointer): integer; virtual;
  143.     procedure WMSize(var Msg: TMessage);
  144.       virtual wm_First + wm_Size;
  145.     procedure WMSetFocus(var Msg: TMessage);
  146.       virtual wm_First + wm_SetFocus;
  147.     procedure WMMeasureItem(var Msg: TMessage);
  148.       virtual wm_First + wm_MeasureITem;
  149.     procedure WMDrawItem(var Msg: TMessage);
  150.       virtual wm_First + wm_DrawItem;
  151.     procedure WMDeleteItem(var Msg: TMessage);
  152.       virtual wm_First + wm_DeleteItem;
  153.     procedure WMCompareItem(var Msg: TMessage);
  154.       virtual wm_First + wm_CompareItem;
  155.     procedure DefWndProc(var MSg: Tmessage); virtual;
  156.     procedure ListSel(var Msg: TMessage);
  157.       virtual id_First + 101;
  158.     procedure RebuildWindow(var Msg: Tmessage);
  159.       virtual cm_First + cm_Rebuild;
  160.     procedure CMClose(var MSg: TMessage);
  161.       virtual cm_First + cm_Close;
  162.     procedure CMSaveAs(var Msg: Tmessage);
  163.       virtual cm_First + cm_SaveAs;
  164.   end;
  165.  
  166.   PSortListWin = ^TSortListWin;
  167.   TSortListWin = object(TListWin)
  168.     SortOpt: Word;
  169.     constructor Init(AParent: PWindowsObject; ATitle: PChar; AOwnerDraw: Boolean);
  170.     destructor Done; virtual;
  171.     procedure ChangeSortOpt(NewOpt: Word);
  172.     procedure WMSetFocus(var Msg: TMessage);
  173.       virtual wm_First + wm_SetFocus;
  174.     procedure CMsbAddress(var Msg: TMessage);
  175.       virtual cm_First + cm_sbAddress;
  176.     procedure CMsbHAndle(var Msg: TMessage);
  177.       virtual cm_First + cm_sbHandle;
  178.     procedure CMsbSize(var Msg: TMessage);
  179.       virtual cm_First + cm_sbSize;
  180.     procedure CMsbType(var Msg: TMessage);
  181.       virtual cm_First + cm_sbType;
  182.     procedure CMsbModule(var Msg: TMessage);
  183.       virtual cm_First + cm_sbModule;
  184.     procedure AdjustMenu;
  185.   end;
  186.  
  187. function StrPad(P: PChar; sz: Integer): PChar;
  188. function GetModuleName(hMod: Word; P: PChar): PChar;
  189. function IsTaskOf(hTask,hMod: Thandle): Boolean;
  190. function IsValidSelector(s: Word): Boolean;
  191. function Compare32(var x1, x2): Integer;
  192. function PtrFromHandle(H: THandle): Pointer;
  193. function DefaultSortOpt: Word;
  194. function TilingMethod: Word;
  195. function DescendantOf(AncestorType, ThisObj: Pointer): Boolean;
  196.  
  197. function HexB(Dest: PChar; B: Byte): PChar;
  198. function HexW(Dest: PChar; I: Word): PChar;
  199. function HexL(Dest: PChar; L: LongInt): PChar;
  200. function HexPtr(Dest: PChar; P: Pointer): PChar;
  201.  
  202. { Global Help wrapper stuff }
  203. const
  204.   HelpOpen: Boolean = False;
  205.   HelpFID: PChar = 'HEAPSPY.HLP';
  206.   HelpWnd: HWND = 0;
  207.  
  208. procedure DoHelp(wCommand: Word; dwData: LongInt);
  209. procedure CloseHelp;
  210.  
  211. function DoFontDialog(AParent: PWindowsObject; LF: PLogFont;
  212.   ATitle: PChar): Bool;
  213. function DoFileSaveDialog(AParent: PWindowsObject; AOptions: LongInt;
  214.   AFileName: PChar; AMaxLen: Integer): Bool;
  215.  
  216. implementation
  217.  
  218. function DoFontDialog(AParent: PWindowsObject; LF: PLogFont;
  219.   ATitle: PChar): Bool;
  220. var
  221.   CF: TChooseFont;
  222. begin
  223.   FillChar(CF,Sizeof(CF),0);
  224.   with CF do
  225.   begin
  226.     lStructSize := SizeOf(CF);
  227.     if AParent <> nil then
  228.       hwndOwner := AParent^.HWindow;
  229.     lpLogFont := LF;
  230.     Flags := cf_ScreenFonts or cf_FixedPitchOnly or cf_InitToLogFontStruct;
  231.   end;
  232.   DoFontDialog := ChooseFont(CF);
  233. end;
  234.  
  235. function DoFileSaveDialog(AParent: PWindowsObject; AOptions: LongInt;
  236.   AFileName: PChar; AMaxLen: Integer): Bool;
  237. var
  238.   OFN: TOpenFileName;
  239.   TempName: array[0..fsFileName] of Char;
  240.   TempExt: array[0..fsExtension] of Char;
  241. begin
  242.   FillChar(OFN,Sizeof(OFN),0);
  243.   with OFN do
  244.   begin
  245.     lStructSize := SizeOf(OFN);
  246.     if AParent <> nil then
  247.       hwndOwner := AParent^.HWindow;
  248.     Flags := AOptions;
  249.     hInstance := System.hInstance;
  250.     lpstrFilter := nil;
  251.     lpstrTitle := nil;
  252.  
  253.     GetMem(lpstrFile, Succ(fsPathName));
  254.     nMaxFile := Succ(fsPathName);
  255.     lpstrFileTitle := nil;
  256.     nMaxFileTitle := 0 ;
  257.     GetMem(lpstrInitialDir, Succ(fsDirectory));
  258.     FileExpand(lpstrFile, AFileName);
  259.     FileSplit(lpstrFile, lpstrInitialDir, TempName, TempExt);
  260.     lpstrDefExt := @TempExt[1];
  261.     StrCat(StrCopy(lpstrFile, TempName), TempExt);
  262.   end;
  263.   DoFileSaveDialog := GetSaveFileName(OFN);
  264.   StrLCopy(AFileName, OFN.lpstrFile, AMaxLen);
  265.   FreeMem(OFN.lpstrInitialDir, Succ(fsDirectory));
  266.   FreeMem(OFN.lpstrFile, Succ(fsPathName));
  267. end;
  268.  
  269. function DescendantOf(AncestorType, ThisObj: Pointer): Boolean;
  270. type
  271.   TVMT = record
  272.     dwSize: LongInt;
  273.     DMTOfs: Word;
  274.   end;
  275. var
  276.   DMTOfs, TargetDMT: Word;
  277. begin
  278.   DescendantOf := True;
  279.   DMTOfs := TVMT(ThisObj^).DMTOfs;
  280.   TargetDMT := TVMT(AncestorType^).DMTOfs;
  281.   while DMTOfs <> 0 do
  282.   begin
  283.     if DMTOfs = TargetDMT then Exit;
  284.     DMTOfs := Word(Ptr(DSeg, DMTOfs)^);
  285.   end;
  286.   DescendantOf := False;
  287. end;
  288.  
  289. procedure DoHelp;
  290. begin
  291.   if HelpWnd = 0 then
  292.     HelpWnd := Application^.MainWindow^.HWindow;
  293.   if WinHelp(HelpWnd,HelpFID,wCommand,dwData) then
  294.     if not HelpOpen then
  295.       HelpOpen := true;
  296. end;
  297.  
  298. procedure CloseHelp;
  299. begin
  300.   if HelpOpen then
  301.     WinHelp(HelpWnd, HelpFID, help_Quit, 0);
  302. end;
  303.  
  304. function DefaultSortOpt: Word;
  305. var
  306.   I: Word;
  307. begin
  308.   for I := cm_sbAddress to cm_sbModule do
  309.     if Glbl.SortOpt[I] then
  310.     begin
  311.       DefaultSortOpt := I;
  312.       Exit;
  313.     end;
  314. end;
  315.  
  316. function TilingMethod: Word;
  317. var
  318.   I: Word;
  319. begin
  320.   for I := op_Vertical to op_Horizontal do
  321.     if Glbl.WinTile[I] then
  322.     begin
  323.       TilingMethod := I;
  324.       Exit;
  325.     end;
  326. end;
  327.  
  328. function IsValidSelector(S: Word): Boolean; assembler;
  329. asm
  330.     XOR    AX,AX  { assume failure }
  331.     CMP    S,0    { 386 bug workaround: LAR on a 0 selector doesn't work }
  332.     JE    @1
  333.     LAR    BX,S   { Get Access rights }
  334.     JNZ    @1     { Zero flag is clear if the selector is invalid }
  335.     INC    AX
  336. @1:
  337. end;
  338.  
  339. function PtrFromHandle(H: THandle): Pointer; assembler;
  340. asm
  341.     MOV    DX,H
  342.     AND    DX,0FFF8H
  343.     MOV    AX,DS
  344.     AND    AX,7
  345.     OR    DX,AX
  346.     PUSH    DX
  347.     CALL    IsValidSelector
  348.     OR    AL,AL
  349.     JNZ    @1
  350.     XOR    DX,DX
  351. @1:    XOR    AX,AX
  352. end;
  353.  
  354. function StrPad(P: PChar; sz: Integer): PChar;
  355. var
  356.   I, Len: Integer;
  357. begin
  358.   Len := StrLen(P);
  359.   for I := Len to Pred(Sz) do P[I] := ' ';
  360.   P[sz] := #0;
  361.   StrPad := P;
  362. end;
  363.  
  364. function GetModuleName(hMod: Word; P: PChar): PChar;
  365. var
  366.   Modl: TModuleEntry;
  367.   Tsk : TTaskEntry;
  368.   Temp: array[0..128] of Char;
  369. begin
  370.   Tsk.dwSize := Sizeof(TTaskEntry);
  371.   Modl.dwSize := Sizeof(TModuleEntry);
  372.   if ModuleFindHandle(@Modl,hMod) <> 0 then
  373.     StrCopy(P,Modl.szModule)
  374.   else if TaskFindHandle(@Tsk,hMod) then
  375.     StrCopy(P,Tsk.szModule)
  376.   else
  377.     P[0] := #0;
  378.   GetModuleName := P;
  379. end;
  380.  
  381. function IsTaskOf(hTask,hMod: Thandle): Boolean;
  382. var
  383.   Tsk : TTaskEntry;
  384. begin
  385.   IsTaskOf := false;
  386.   Tsk.dwSize := Sizeof(TTaskEntry);
  387.   if TaskFindHandle(@Tsk,hTask) then
  388.     IsTaskOf := Tsk.hModule = hMod;
  389. end;
  390.  
  391.  
  392. function Compare32(var x1,x2): Integer;
  393. var
  394.   a1: array[0..3] of byte absolute x1;
  395.   a2: array[0..3] of byte absolute x2;
  396.   i: Integer;
  397. begin
  398.   Compare32 := 0;
  399.   for i := 3 downto 0 do
  400.     if a1[i] <> a2[i] then
  401.     begin
  402.       if a1[i] < a2[i] then Compare32 := -1 else Compare32 := 1;
  403.       Exit;
  404.     end;
  405. end;
  406.  
  407. type
  408.   LongRemap = record
  409.     case Word of
  410.       0:(Long: LongInt);
  411.       1:(LoWord, HiWord: Word);
  412.    end;
  413.  
  414. function HexB(Dest: PChar; B: Byte): PChar;
  415. const
  416.   h: array[0..15] of Char = '0123456789ABCDEF';
  417. begin
  418.   Dest[0] := h[b shr 4];
  419.   Dest[1] := h[b and $0F];
  420.   Dest[2] := #0;
  421.   HexB := Dest;
  422. end;
  423.  
  424. function HexW(Dest: PChar; I: Word): PChar;
  425. begin
  426.   HexB(Dest, Hi(I));
  427.   HexB(@Dest[2], Lo(I));
  428.   HexW := Dest;
  429. end;
  430.  
  431. function HexL(Dest: PChar; l:LongInt): PChar;
  432. var
  433.   lr: LongRemap absolute l;
  434. begin
  435.   HexW(Dest, lr.hiWord);
  436.   HexW(@Dest[4], lr.loWord);
  437.   HexL := Dest;
  438. end;
  439.  
  440. function HexPtr(Dest: PChar; p:Pointer) :PChar;
  441. var
  442.   lr: longremap absolute p;
  443. begin
  444.   HexW(Dest, lr.hiWord);
  445.   Dest[4] := ':';
  446.   HexW(@Dest[5], lr.loWord);
  447. end;
  448.  
  449. constructor TBWCCDlg.Init(AParent: PWindowsObject; AName: PChar;
  450.   AHelpCtx: LongInt);
  451. begin
  452.   HelpCtx := AHelpCtx;
  453.   inherited Init(AParent,AName);
  454. end;
  455.  
  456. function TBWCCDlg.GetClassName: PChar;
  457. begin
  458.   GetClassNAme := 'BorDlg';
  459. end;
  460.  
  461. procedure TBWCCDlg.WMDestroy;
  462. begin
  463.   inherited WMDestroy(Msg);
  464. end;
  465.  
  466. procedure TBWCCDlg.HelpReq;
  467. begin
  468.  if HelpCtx <> 0 then
  469.    DoHelp(HELP_CONTEXT,helpCtx)
  470.  else
  471.    DoHelp(HELP_INDEX,0);
  472. end;
  473.  
  474. constructor TListWin.Init;
  475. begin
  476.   inherited Init(AParent, ATitle);
  477.   New(List,Init(@Self,101,0,0,100,100));
  478.   PrevChildWnd := 0;
  479.   with List^.Attr do
  480.   begin
  481.     Style := Style or lbs_Sort;
  482.     Style := Style or lbs_NoIntegralHeight;
  483.     Style := Style and (not (ws_Border));
  484.     Style := Style or ws_HScroll;
  485.     if AOwnerDraw then
  486.     begin
  487.       Style := Style or lbs_OwnerDrawVariable;
  488.       Style := Style and (not lbs_HasStrings);
  489.     end;
  490.   end;
  491. end;
  492.  
  493.  
  494. procedure TListWin.SetupWindow;
  495. begin
  496.   inherited SetupWindow;
  497.   SendMessage(List^.HWindow, wm_SetFont, ListBoxFont, 0);
  498.   if not glbl.RebuildOnActivate then BuildList;
  499.   SendMessage(List^.HWindow, lb_SetCurSel, 0, 0);
  500.   SendMessage(List^.HWindow, lb_SetHorizontalExtent, 1000, 0);
  501. end;
  502.  
  503. procedure TListWin.BuildList;
  504. begin
  505.   { This abstract window doesn't know HOW to build a list }
  506. end;
  507.  
  508. function TListWin.HandleSelect(LeftClick: Boolean): Boolean;
  509. begin
  510.   HandleSelect := false;
  511. end;
  512.  
  513. procedure TListWin.ListSel;
  514. begin
  515.   if (Msg.lParamHi = lbn_DblClk) or (Msg.lParamHi = lbn_rDblClk) then
  516.   begin
  517.     if not HandleSelect(Msg.lParamHi = lbn_DblClk) then
  518.       BWCCMessageBox(HWindow, 'This function has not been implemented',
  519.         'Inspector', mb_IconStop + mb_OK);
  520.   end
  521.   else
  522.     DefWndProc(MSg);
  523. end;
  524.  
  525. procedure TListWin.WMSize;
  526. begin
  527.   inherited WMSize(MSg);
  528.   if Msg.wPAram <> SizeIconic then
  529.     MoveWindow(List^.HWindow, 0, 0, Msg.lParamLo, Msg.LparamHi, True);
  530. end;
  531.  
  532. procedure TListWin.WMSetFocus;
  533. begin
  534.   DefWndProc(Msg);
  535.   SetFocus(List^.HWindow);
  536. end;
  537.  
  538. procedure TListWin.CMClose;
  539. begin
  540.   Destroy;
  541. end;
  542.  
  543. procedure TListWin.CMSaveAs;
  544. var
  545.   F: text;
  546.   P: Pointer;
  547.   Txt: PChar;
  548.   Idx: Integer;
  549.   FileName: array[0..80] of Char;
  550. begin
  551.   StrCopy(FileName, 'HEAPSPY.LOG');
  552.   if not DoFileSaveDialog(@Self, ofn_HideReadOnly, FileName, 80) then Exit;
  553.   Assign(F, FileName);
  554.   Append(F);
  555.   if IOResult <> 0 then
  556.     Rewrite(f);
  557.   Writeln(F, '*** Log of ', Attr.Title, ' ***');
  558.   for Idx := 0 to Pred(List^.GetCount) do
  559.   begin
  560.     P := Pointer(SendMessage(List^.HWindow, lb_GetItemData, idx, 0));
  561.     Txt := GetItemString(p);
  562.     Writeln(F, Txt);
  563.     StrDispose(Txt);
  564.   end;
  565.   Writeln(F);
  566.   Close(F);
  567. end;
  568.  
  569. function TListWin.GetClassName: PChar;
  570. begin
  571.   GetClassName := 'HWListWin';
  572. end;
  573.  
  574. procedure TListWin.GetWindowClass(var WndClass: TWndClass);
  575. begin
  576.   inherited GetWindowClass(WndClass);
  577.   WndClass.hIcon := LoadIcon(hInstance, PChar(ico_Module));
  578. end;
  579.  
  580. function TListWin.GetItemString(P: Pointer): PChar;
  581. begin
  582. end;
  583.  
  584. procedure TListWin.WMMeasureItem;
  585. begin
  586.  with PMeasureItemStruct(Msg.lPAram)^ do
  587.    itemHeight := Abs(HeapFontLF.lfHeight) + 2;
  588. end;
  589.  
  590. procedure TListWin.WMDrawItem;
  591. var
  592.   Txt: PChar;
  593.   DoInvert: Boolean;
  594. begin
  595.   with PDrawItemStruct(Msg.lParam)^ do
  596.     if (CtlType = odt_LISTBOX) and (CtlID = 101) then
  597.     begin
  598.       DoInvert := itemAction = oda_Select;
  599.       if (((ItemAction and oda_DrawEntire) <> 0) and
  600.         (itemID <> $FFFF)) then
  601.       begin
  602.         if (itemstate and ods_Selected) = ods_Selected then
  603.           DoInvert := true;
  604.         Txt := GetItemString(Pointer(ItemData));
  605.         TextOut(hDC, 0, rcItem.Top, Txt, StrLen(Txt));
  606.         StrDispose(Txt);
  607.       end;
  608.       if DoInvert then
  609.         InvertRect(hDC,rcItem);
  610.     end
  611.     else
  612.       DefWndProc(Msg);
  613. end;
  614.  
  615. procedure TListWin.DeleteItem;
  616. begin
  617. end;
  618.  
  619. {- A simple comparison of the values of the PointerS.  Should normally
  620.    be overridden by a descendant }
  621. function TListWin.Less(p1,p2: Pointer): Integer;
  622. begin
  623.   if LongInt(P1) < LongInt(P2) then Less := -1
  624.   else if LongInt(P1) > LongInt(P2) then Less := 1
  625.   else Less := 0;
  626. end;
  627.  
  628. procedure TListWin.WMCompareItem;
  629. begin
  630.   with Msg do
  631.     Msg.Result := Less(Pointer(PCompareItemStruct(lParam)^.itemdata1),
  632.       Pointer(PCompareItemStruct(lParam)^.itemdata2));
  633. end;
  634.  
  635. procedure TListWin.WMDeleteItem;
  636. begin
  637.   DeleteItem(Pointer((PDeleteItemStruct(Msg.lParam)^.itemData)));
  638. end;
  639.  
  640. procedure TListWin.RebuildWindow(var Msg: TMessage);
  641. begin
  642.   SendMessage(List^.HWindow, lb_ResetContent, 0, 0);
  643.   SendMessage(List^.HWindow, wm_SetRedraw, 0, 0);
  644.   BuildList;
  645.   if Msg.Message <> wm_MDIActivate then
  646.   begin
  647.     SendMessage(List^.HWindow, lb_SetCurSel, 0 ,0);
  648.     SendMessage(List^.HWindow, wm_SetRedraw, 1, 0);
  649.     InvalidateRect(List^.HWindow, nil, True);
  650.   end;
  651. end;
  652.  
  653. procedure TListWin.DefWndProc;
  654. var
  655.   TopPos,
  656.   LastPos: Integer;
  657. begin
  658.   with Msg do
  659.   case Message of
  660.     wm_MDIActivate:
  661.       begin
  662.         if wParam = 0 then
  663.           PrevChildWnd := 0
  664.         else
  665.         begin
  666.           PrevChildWnd := lParamHi;
  667.           if (PrevChildWnd = 0) then
  668.             PrevChildWnd := HWindow;
  669.           if glbl.RebuildOnActivate then
  670.           begin
  671.             TopPos := SendMessage(List^.HWindow,LB_GetTopIndex,0,0);
  672.             LastPos := List^.GetSelIndex;
  673.             RebuildWindow(Msg);
  674.             List^.SetSelIndex(LastPos);
  675.             SendMessage(List^.HWindow,LB_SetTopIndex,TopPos,0);
  676.             SendMessage(List^.HWindow,wm_SETREDRAW,1,0);
  677.             InvalidateRect(List^.HWindow,nil,true);
  678.           end;
  679.         end;
  680.         inherited DefWndProc(Msg);
  681.       end;
  682.    wm_MouseActivate:
  683.      if (HWindow <> PrevChildWnd) and (lParamLo = HTClient) then
  684.        Result := MA_ACTIVATEANDEAT
  685.      else
  686.        Result := MA_ACTIVATE;
  687.    wm_SetCursor:
  688.      begin
  689.        PrevChildWnd := HWindow;
  690.        inherited DefWndProc(Msg);
  691.      end;
  692.    else
  693.      inherited DefWndProc(Msg);
  694.    end;
  695. end;
  696.  
  697. constructor TSortListWin.Init;
  698. begin
  699.   SortOpt := DefaultSortOpt;
  700.   inherited Init(AParent, ATitle, AOwnerDraw);
  701. end;
  702.  
  703. destructor TSortListWin.Done;
  704. begin
  705.   SortOpt := 0;
  706.   AdjustMenu;
  707.   inherited Done;
  708. end;
  709.  
  710. procedure TSortListWin.AdjustMenu;
  711. var
  712.   Menu: hMenu;
  713.   CtlID: Word;
  714.   Wnd : HWND;
  715. begin
  716.   Wnd := Application^.MainWindow^.HWindow;
  717.   if Wnd = 0 then Exit;
  718.   Menu := GetMenu(Wnd);
  719.   if Menu = 0 then Exit;
  720.   for CtlID := cm_sbAddress to cm_sbModule do
  721.     CheckMenuItem(Menu, CtlID, mf_ByCommand or mf_Unchecked);
  722.   if SortOpt <> 0 then
  723.     CheckMenuItem(Menu, SortOpt, mf_ByCommand or mf_Checked);
  724. end;
  725.  
  726.  
  727. procedure TSortListWin.ChangeSortOpt;
  728. var
  729.   OldSortOpt: Word;
  730.   Msg: TMessage;
  731. begin
  732.   OldSortOpt := SortOpt;
  733.   SortOpt := NewOpt;
  734.   AdjustMenu;
  735.   if OldSortOpt <> SortOpt then RebuildWindow(Msg);
  736. end;
  737.  
  738. procedure TSortListWin.CMsbAddress(var Msg: TMessage);
  739. begin
  740.   ChangeSortOpt(cm_sbAddress);
  741. end;
  742.  
  743. procedure TSortListWin.CMsbHAndle(var Msg: TMessage);
  744. begin
  745.   ChangeSortOpt(cm_sbHandle);
  746. end;
  747.  
  748. procedure TSortListWin.CMsbSize(var Msg: TMessage);
  749. begin
  750.   ChangeSortOpt(cm_sbSize);
  751. end;
  752.  
  753. procedure TSortListWin.CMsbType(var Msg: TMessage);
  754. begin
  755.   ChangeSortOpt(cm_sbType);
  756. end;
  757.  
  758. procedure TSortListWin.CMsbModule(var Msg: TMessage);
  759. begin
  760.   ChangeSortOpt(cm_sbModule);
  761. end;
  762.  
  763. procedure TSortListWin.WMSetFocus;
  764. begin
  765.   inherited WMSetFocus(Msg);
  766.   AdjustMenu;
  767. end;
  768.  
  769. procedure TMyListBox.WMRButtonDown(var Msg: TMessage);
  770. begin
  771.   SetFocus(Parent^.HWindow);
  772.   SendMessage(HWindow, wm_LButtonDown, Msg.wParam, Msg.lParam);
  773. end;
  774.  
  775. procedure TMyListBox.WMRButtonUp(var Msg: TMessage);
  776. begin
  777.   SendMessage(HWindow, wm_LButtonUp,Msg.wParam,Msg.lParam);
  778. end;
  779.  
  780. procedure TMyListBox.WMRButtonDblClk(var Msg: TMessage);
  781. begin
  782.   SendMessage(Parent^.HWindow,wm_COMMAND,101,lbn_RDBLCLKMask or HWindow);
  783. end;
  784.  
  785. procedure TMyListBox.WMKeyDown(var Msg: TMessage);
  786. { an apparent bug in Windows 3.1 causes a VK_NEXT keypress to be
  787.   non-functional in a ownerdraw-variable list box}
  788. var
  789.   SelItem,TopItem,MaxItem: Integer;
  790.   ItemHeight,ItemsPerPage: Integer;
  791.   PageDim: TRect;
  792. begin
  793.   if Msg.wParam = vk_Return then
  794.      PostMessage(Parent^.HWindow, wm_Command, Attr.ID,
  795.        (lbn_DBLCLK shl 16) or HWindow);
  796.   if Msg.wParam <> vk_Next then
  797.   begin
  798.     DefWndProc(Msg);
  799.     Exit;
  800.   end;
  801.   MaxItem := Pred(GetCount);
  802.   ItemHeight := SendMessage(HWindow, lb_GetItemHeight, 0, 0);
  803.   GetClientRect(HWindow,PageDim);
  804.   with PageDim do
  805.     ItemsPerPage := Pred(Bottom div ItemHeight);
  806.   SelItem := GetSelIndex;
  807.   if SelItem = MaxItem then Exit;
  808.   Inc(SelItem,ItemsPerPage);
  809.   if SelItem >= GetCount then SelItem := MaxItem;
  810.   SendMessage(HWindow, wm_SetRedraw, 0, 0);
  811.   SendMessage(HWindow, lb_SetCurSel, SelItem, 0);
  812.   SendMessage(HWindow, wm_SetRedraw, 1 ,0);
  813.   InvalidateRect(HWindow, nil, True);
  814. end;
  815.  
  816. procedure LoadINIStuff;
  817. var
  818.   Temp: Word;
  819. begin
  820.   Temp := GetPrivateProfileInt(OptionsKey, RebuildKey, 0, INIFile);
  821.   if Temp > 1 then Temp := 0;
  822.   Glbl.RebuildOnActivate := WordBool(Temp);
  823.  
  824.   Temp := GetPrivateProfileInt(OptionsKey, SpeedBarKey, 1, INIFile);
  825.   if Temp > 1 then Temp := 0;
  826.   Glbl.UseSpeedBar := WordBool(Temp);
  827.  
  828.   FillChar(Glbl.SortOpt,Sizeof(Glbl.SortOpt),0);
  829.   Temp := GetPrivateProfileInt(OptionsKey, SortOptKey, 0, INIFile);
  830.   if Temp > 4 then Temp := 0;
  831.   Inc(Temp,cm_sbAddress);
  832.   Glbl.SortOpt[Temp] := True;
  833.  
  834.   FillChar(Glbl.WinTile, Sizeof(Glbl.WinTile), 0);
  835.   Temp := GetPrivateProfileInt(OptionsKey, WinTileKey, 0, INIFile);
  836.   if Temp > 1 then Temp := 0;
  837.   Inc(Temp, op_Vertical);
  838.   Glbl.WinTile[Temp] := True;
  839. end;
  840.  
  841. var
  842.   SaveExit: Pointer;
  843.  
  844. procedure UnitExit; far;
  845. begin
  846.   ExitProc := SaveExit;
  847.   if ListBoxFont <> 0 then DeleteObject(ListBoxFont);
  848.   if HexDumpFont <> 0 then DeleteObject(HexDumpFont);
  849. end;
  850.  
  851. begin
  852.   ListBoxFont := GetStockObject(Ansi_Fixed_Font);
  853.   GetObject(ListBoxFont, SizeOf(TLogFont), @HeapFontLF);
  854.   ListBoxFont := CreateFontIndirect(HeapFontLF);
  855.  
  856.   HexDumpFont := GetStockObject(Oem_Fixed_Font);
  857.   GetObject(HexDumpFont, SizeOf(TLogFont), @HexDumpLF);
  858.   HexDumpFont := CreateFontIndirect(HexDumpLF);
  859.  
  860.   SaveExit := ExitProc;
  861.   ExitProc := @UnitExit;
  862.   WaitCursor := LoadCursor(0, PChar(idc_Wait));
  863.   ArrowCursor := LoadCursor(0, PChar(idc_Arrow));
  864.   LoadINIStuff;
  865. end.
  866.